home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / NEWSOFT / AUGUST / WORKDISC / !Forthmacs / lib / file2block < prev    next >
Text File  |  1997-04-12  |  2KB  |  58 lines
  1. \ Convert from a stream file to a block file.
  2. \
  3. \ Stream files contain variable-length lines terminated
  4. \ by a newline character, without trailing blanks.  Characters
  5. \ are lower case.
  6. \
  7. \ Block files contain a sequence of records each with c/l
  8. \ (usually 64) upper case characters.
  9. \
  10. \ Any lines in the stream file which are longer than c/l characters
  11. \ are truncated.  Any control character (including tab) in the
  12. \ stream file is changed to a blank in the block file.
  13. \
  14. \ ftob   \ stream-filename block-filename  ( -- )
  15. \ "ftob  ( stream-filename block-filename -- )
  16. \ (ftob  ( -- )
  17. \    Convert stream file in ifd to block file in ofd
  18.  
  19. only forth also definitions
  20. needs fgetline extend/filetool.fth
  21.  
  22. only forth also hidden definitions
  23.  
  24. 64 constant c/l
  25. variable ftob-#lines
  26. : sanitize    ( adr len -- )    \ Convert control characters to blanks
  27.     bounds
  28.     ?do i c@ dup bl < swap h# 7f = or if bl i c! then
  29.     loop ;
  30. : ftob-file    ( -- )
  31.     ftob-#lines off
  32.     begin    pad c/l 1+ blank
  33.         pad ifd @  fgetline        ( string flag)
  34.     while    count dup c/l >
  35.         if  ." Truncating: " 2dup type cr  then  ( adr len )
  36.         2dup upper   2dup sanitize   ( adr len )
  37.         drop c/l  ofd @ fputs
  38.         1 ftob-#lines +!
  39.     repeat ;
  40. : roundup    ( n1 boundary -- n2 )    \ Round n1 up to next mod "boundary"
  41.     tuck 1- +            ( boundary  n1+ )
  42.     over / * ;
  43. only forth hidden also forth definitions
  44.  
  45. : (ftob        ( -- )        \ Convert stream file at ifd to block file at ofd
  46.     ftob-file
  47.     \ Extend the block file to a multiple of 16 lines
  48.     pad c/l 1+ blank
  49.     ftob-#lines @ d# 16 roundup   ftob-#lines @
  50.     ?do  pad c/l ofd @ fputs  loop
  51.     ofd @ fclose  ifd @ fclose ;
  52. : "ftob  ( in-file-name out-file-name -- )
  53.     new-file  read-open  (ftob ;
  54. : ftob  \ stream-file-name block-file-name ( -- )
  55.     blword astring "move blword  "ftob ;
  56.  
  57. only forth also definitions
  58.